;;;;;; constant-pool.scm - Runtime Constant Pool module.    -*- Mode: Scheme -*-
;;;;;; Author: Erik Silkensen <silkense@colorado.edu>
;;;;;; Version: 28 Jun 2009

#lang scheme

(require srfi/13)           ; provides String Libraries
(require "binary-io.scm")

;;; See Ch. 4.4 of the Java(TM) Virtual Machine Specification for
;;; documentation of the Constant Pool:
;;; <http://java.sun.com/docs/books/jvms>

;;; This module provides a constructor for a Constant Pool object.

;;; All Constant Pool methods that insert an info structure into the
;;; Constant Pool return the index of the structure that was inserted.

;;; The Constant Pool object follows the pattern in Ch. 3 of Structure
;;; and Interpretation of Computer Programs. The object is a procedure:
;;;     (let ((cp (make-constant-pool)))
;;;       ((cp '<method>) <arg1> <arg2>))        

(provide make-constant-pool sig-size)

(define (sig-size sig include-return)
  ;; This algorithm is ported from org.python.compiler.ConstantPool,
  ;; part of the Jython project: <http://www.jython.org>. It calculates
  ;; the "size" of a signature with regard to the operand stack.
  ;; Include-return toggles whether or not the return value portion of
  ;; the signature is included in the size.
  (let ((n (string-length sig)))
    (define (it i stack array ret)
      (if (< i n)
          (let ((c (string-ref sig i)))
            (cond ((char=? #\) c) 
                   (it (if include-return (+ i 1) n) stack array #t))
                  ((char=? #\[ c)
                   (it (+ i 1) stack #t ret))
                  ((char=? #\V c)
                   (it (+ i 1) stack array ret))
                  ((or (char=? #\D c) (char=? #\J c))
                   (it (+ i 1) ((if ret + -) stack (if array 1 2)) #f ret))
                  ((char=? #\L c)
                   (let ((j (string-index sig #\; i)))
                     (it (+ j 1) ((if ret + -) stack 1) #f ret)))
                  (else
                   (it (+ i 1) ((if ret + -) stack 1) #f ret))))
          stack))
    (it 1 0 #f #f)))

(define (make-constant-pool)
  (define (Class name)
    ;; Inserts a Class_info structure into the Constant Pool. Name
    ;; should be a fully qualified class or interface name encoded in
    ;; internal form (4.2). 
    (let ((c (Utf8 name)))
      (write-byte #x07 buff)
      (write-short c buff)
      (add-constant 1)))
  (define (Fieldref class-name name type)
    ;; Inserts a Fieldref_info structure into the Constant Pool.
    ;; Class-name should be a fully qualified class or interface name
    ;; encoded in internal name (4.2). Name and type should be name
    ;; (2.2, 2.7) and descriptor (4.3.2, 4.3.3) strings.
    (let* ((ic (Class class-name))
           (nt (NameAndType name type)))
      (write-byte #x09 buff)
      (write-short ic buff)
      (write-short nt buff)
      (let ((index (add-constant 1))
            (size (if (or (equal? "D" type)   ; double and long types
                          (equal? "J" type))  ; require two units in
                      2                       ; constant pool
                      1)))
        (hash-set! sizes index size)
        index)))
  ;; Inserts a Methodref_info structure into the Constant Pool.
  ;; Class-name should be a fully qualified class name encoded in
  ;; internal form (4.2). Name and type should be name (2.2, 2.7) and
  ;; descriptor (4.3.2, 4.3.3) strings.
  (define (Methodref class-name name type)
    (gen-methodref #x0a class-name name type))
  (define (InterfaceMethodref class-name name type)
    ;; Inserts a InterfaceMethodref_info structure into the Constant
    ;; Pool. Class-name should be a fully qualified interface name
    ;; encoded in internal form (4.2). Name and type should be name
    ;; (2.2, 2.7) and descriptor (4.3.2, 4.3.3) strings.
    (gen-methodref #x0b class-name name type))
  (define (gen-methodref tag class-name name type)
    ;; <PRIVATE> Methodref and InterfaceMethodref delegate to this.
    (let* ((ic (Class class-name))
           (nt (NameAndType name type)))
      (write-byte tag buff)
      (write-short ic buff)
      (write-short nt buff)
      (let ((index (add-constant 1)))
        (hash-set! sizes index (sig-size type #t))
        index)))
  (define (String string-constant)
    ;; Inserts a String_info structure into the Constant Pool.
    ;; String-constant should be the string to which the String object
    ;; is to be initialized.
    (let ((i (Utf8 string-constant)))
      (write-byte #x08 buff)
      (write-short i buff)
      (add-constant 1)))
  (define (Integer integer-constant)
    ;; Inserts a Integer_info structure into the Constant Pool.
    ;; Integer-constant is the value of the int constant (4.4.4).
    (write-byte #x03 buff)
    (write-int integer-constant buff)
    (add-constant 1))
  (define (Float float-constant)
    ;; Inserts a Float_info structure into the Constant Pool.
    ;; Float-constant is the value of the float constant (4.4.4).
    (write-byte #x04 buff)
    (write-float float-constant buff)
    (add-constant 1))
  (define (Long long-constant)
    ;; Inserts a Long_info structure into the Constant Pool.
    ;; Long-constant is the value of the long constant (4.4.5).
    (write-byte #x05 buff)
    (write-long long-constant buff)
    (add-constant 2))
  (define (Double double-constant)
    ;; Inserts a Double_info structure into the Constant Pool.
    ;; Double-constant is the value of the double constant (4.4.5).
    (write-byte #x06 buff)
    (write-double double-constant buff)
    (add-constant 2))
  ;; Inserts a NameAndType_info structure into the Constant Pool. Name
  ;; and type are name (2.2, 2.7) and descriptor (4.3.2, 4.3.3) strings.
  (define (NameAndType name type)
    (let* ((n (Utf8 name))
           (t (Utf8 type)))
      (write-byte #x0c buff)
      (write-short n buff)
      (write-short t buff)
      (add-constant 1)))
  (define (Utf8 string-constant)
    ;; Inserts a Utf8_info structure into the Constant Pool.
    ;; String-constant is the UTF-8 string constant (4.4.7).
    (write-byte #x01 buff)
    (write-utf string-constant buff)
    (add-constant 1))
  (define (add-constant slots)
    ;; <PRIVATE> Adds slots to the Constant Pool. Slots should be the
    ;; number of slots to add. The bytes for the constant to be added
    ;; are retrieved and removed from the buff port, and only written to
    ;; the pool port if they have not been previously written. The index
    ;; of the added constant is returned.
    (let* ((data (get-output-bytes buff #t))
           (i (hash-ref constants data '())))
      (when (null? i)
            (write-bytes data pool)
            (set! i index)
            (hash-set! constants data i)
            (hash-set! sizes (+ index 1) slots)
            (set! index (+ index slots)))
      (+ i 1)))
  (define (write [out (current-output-port)])
    ;; Writes the Constant Pool to the output port.
    (write-short (+ index 1) out)
    (write-bytes (get-output-bytes pool) out))
  (define constants (make-hash))
  (define sizes (make-hash))
  (define buff (open-output-bytes))
  (define pool (open-output-bytes))
  (define index 0)
  (define this
    ;; The object is a procedure that returns a method from this table.
    (let ((method-table `((Class . ,Class)
                          (Fieldref . ,Fieldref)
                          (Methodref . ,Methodref)
                          (InterfaceMethodref . ,InterfaceMethodref)
                          (String . ,String)
                          (Integer . ,Integer)
                          (Float . ,Float)
                          (Long . ,Long)
                          (Double . ,Double)
                          (NameAndType . ,NameAndType)
                          (Utf8 . ,Utf8)
                          (write . ,write)
                          (sizes . ,sizes))))
      (lambda (method)
        (let ((proc (assq method method-table)))
          (if proc
              (cdr proc)
              (error "undefined method -- CONSTANT-POOL" method))))))
  this)
